Developer CD Series 1992 June: ROMin Holiday/ADC Developer CD (1992-06) (''ROMin Holiday'')_iso/Developer Connection - 06-1992.iso/Development Platforms/LISP Related/U. Mass AI & LISP Tools/MODULES/SM/SM.lisp

Text File | 1990-06-25 | 85.1 KB | 1,800 lines | [TEXT/MACA]

; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
; This software was conceived, designed, and written by Dan Suthers
; while supported by the National Science Foundation under grant number
; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
; CA.  Partial support was also received from the Office of Naval Research
; under a University Research Initiative Grant, contract N00014-86-K-0764.
; Mr. Suthers created this software under his own initiative while in an
; academic relationship with the University of Massachusetts.  The above
; copyright notice was a condition placed by University lawyers on approval
; of distribution of this software by Apple Computer, and is not meant to
; imply that this software was created in an employment or "work for hire"
; relationship between the University and Mr. Suthers.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; File:         SM.LISP
; Author:       Dan Suthers
; Created:      07-Nov-87 00:38:00 (Dan Suthers)
; Modified:     22-Jun-90 02:11:42 (Dan Suthers)
; Language:     LISP
; Package:      SM
;
; Description:  Structure Manager.
;
;               Common Lisp Structures are extended to include support
;               for keeping track of structure types defined and of
;               instances of them created; creating, destroying, and
;               printing instances and types; recording and accessing
;               information about the slots; and reuse of structures of
;               destroyed instances to reduce garbage collection.
;
; (c) Copyright 1988, by Daniel D. Suthers
;                        Department of Computer and Information Science
;                        University of Massachusetts
;                        Amherst, Massachusetts 01003
;
; This software was conceived, designed, and written by Dan Suthers
; while supported by the National Science Foundation under grant number
; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
; CA.  Partial support was also received from the Office of Naval Research
; under a University Research Initiative Grant, contract N00014-86-K-0764.
; I wish to acknowledge the generous support of Beverly Woolf, who obtained
; the above grants and encouraged me to pursue my own research interests in
; her lab.  This work would not have been possible without the resources and
; stimulating environment of the Computer and Information Science department.
;
; Permission to use, modify, and distribute this software is granted subject
; to the following restrictions and understandings:
; 1. The file header, including this notice, shall be retained, and may be
;    extended to include documentation of modifications to the software.
; 2. This material is for nonprofit educational and research purposes only.
;    Users are requested, but not required, to inform Mr. Suthers of any
;    noteworthy uses of this software.
; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
;    representation that the operation of this software will be error free,
;    and are under no obligation to provide any services.
; 4. Any user of such software agrees to indemnify and hold harmless Mr.
;    Suthers and the University of Massachusetts from all claims arising
;    out of the use or misuse of this software, or arising out of any
;    accident, injury, or damage whatsoever, and from all costs, counsel
;    fees, and liabilities incurred in or about any such claim, action, or
;    proceeding brought thereon.
; 5. All materials and reports developed as a consequence of the use of
;    this software shall duly acknowledge such use, in accordance with
;    the usual standards of acknowledging credit in academic research.
;
; Status:       In a usable state. Most recent testing:
;               Hewlett Packard 9000       02-Nov-88 Dan Suthers
;               Macintosh II Coral/Allegro 14-Sep-89 Dan Suthers
;               Texas Instruments Explorer 02-Nov-88 Dan Suthers
;               VAX/VMS                    02-Nov-88 Dan Suthers
;
; Changes:
;   10-May-88 Changing slots of the $structure-type$ structure to record type
;     information usable elsewhere, and added macros to access this information.
;     Used to rewrite faster prints.  Improved readability and efficiency of DST,
;     including replacing make-<type> with BOA allocate-<type> for efficiency.
;   12-May-88 Bug in HP CL requires placing :constructor in current package.
;   22-May-88 save-type and load-type moved here from SMEDIT. Now save-type has
;     define-type and compile args. Got rid of "-struct-" in names.
;   23-May-88 Added type declarations.
;   17-Jun-88 Documentation accessable in *-----SM-----*
;   20-Jun-88 Added SLOT-TYPES (recording and access to the declared :type).
;   24-Jun-88 Machine Specific Patches:
;     #+TI Explorer: DST went into recursive dive. The macro expansion of DST
;          normally contains the original (quoted) list structure of the original
;          DST call.  The TI appeared to invoke a recursive expansion of the DST
;          expression, even though it was quoted.  Copying the list solved it.
;     #+VAX: Open-file cannot :create when :io and file does not exist. :Output
;          works. (CCL needs :IO for tabbing.)
;   25-Jun-88 Testing : Type declarations in create-<type> fixed; added type
;     checking to <type> macro. Confirmed that most implementations can only use
;     DST at top level in compiled or preprocessed code.
;   29-Jun-99 Save-Instances added to save specified instances.
;   02-Jul-88 DST now signals continuable error if redefining, since this
;     clobbers all instances (dangerous). Added COPYS.
;   14-Jul-88 Added DEFINE-TYPE.  Both it and DST now can :redefine, and
;     their type option syntax is compatible with defstruct. Added :style
;     :list-macro to prints.  :TYPE, :INITIAL-OFFSET, and :NAMED now work.
;     Destroy-type now undefines functions. Renamed COPYS to COPIES.
;   19-Jul-88 ALLOCATE-<type> now in calling package instead of SM, to avoid
;      collisions if type of same name defined in several packages.  Renamed
;      to SM$ALLOCATE-<type> to avoid collision in calling package.
;   27-Jul-88 CCL :capitalize tried to capitalize "" and died on char ref 0.
;      Bypassed by changing ~A to ~S for all slot values in PRINTS.
;   30-Jul-88 Added proclamations for prints, save-type, and load-type.
;   03-Aug-88 :sort-instances option added to DST; misc other stuff.
;   23-Oct-88 SAVE-TYPE now pretty prints type options when saving
;     definition; in :CCL, compilation of saved files is eval-enqueued.
;     Huge documentation string no longer loaded.
;   01-Nov-88 TYPE-INFO and SLOT-INFO have alternate expansions depending
;     on number of arguments given: more args select info from the alist.
;     Structure-types list kept sorted.
;   13-Nov-88 Slots printed in order the user defined them (no longer sorted).
;   16-Nov-88 SAVE-TYPE now has :init-forms and :append arguments.
;   31-Dec-88 SLOT-INFO and TYPE-INFO now CDR-ASSOC instead of just ASSOC
;     when optional args are given. :COMMENTS type option now recorded as
;     structure's documentation.  COPIES now has copy-tree keyword argument,
;     which defaults T, and copies slot values which are conses.
;   14-Sep-89 LOAD-TYPE modified to run :AFTER-LOAD method if specified as
;     a type option.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#| About the Structure Manager:

Common Lisp Structures are extended to include support for:
- keeping track of structure types defined and of instances of them created;
- creating, destroying, and printing instances and types;
- recording and accessing information about the type and slots definitions;
- reuse of structures of destroyed instances to reduce garbage collection;
- saving to and reloading definitions and instances from files; and
- re-representation of existing instances when a type is redefined.

With the exception of indirect reference to structures through names, SM
attempts to be compatible with syntax of DEFSTRUCT and related functions,
and to provide at least as much functionality.  Currently only the :include
and :conc-name functionality of DEFSTRUCT are not supported.

As a general rule, we define for each type only those functions which need
type-specific arguments.  The other functions are shared between types.
Most applications will primarily be concerned with DST, CREATE-<type>,
<type>, INSTANCES, GETS, DESTROYS, PRINTS, and the structure access
functions.  See these first.

TYPE DEFINITIONS:

  DST (macro) and DEFINE-TYPE (function) define types.  See documentation of
  DST: its syntax is similar to defstruct.  Existing types may be redefined.
  STRUCTURE-TYPES returns a list of all defined types.

  WARNING: DST can only be used at top level on some machines. It expands into:
    (PROGN <check-for-redefinition>
           <record-type-definition>
           (DEFSTRUCT <type+options> ...)
           (DEFUN CREATE-<type> ...)
           (DEFMACRO <type> ...)
           '<type>)
  When not at top level, the preprocessor tries to expand SETFs in CREATE-<type>.
  When the type is :reusable, these include SETFs to <type>-<slot> functions to
  be defined by DEFSTRUCT.  However, at preprocess time, the DEFSTRUCT has not
  been evaluated, even though it occurs before the CREATE-<type> definition. So
  you get a '<type>-<slot> has no setf method' error.  This is not a problem
  with the DEFINE-TYPE function, which may be used when not at top level.

TYPE SPECIFIC FUNCTIONS:

  All standard structure-specific functions defined by DEFSTRUCT are defined in
  the calling package, and have the usual behavior.  The following are also
  defined:

<type> <name> &key <slot> ...                               [No-Eval Macro]

  Instances of the type may be created with this no-eval macro, where
  the <name> is an atom which this instance is accessed with, and the
  keyword arguments correspond to the slot names of uncomputed slots of
  the structure.  The keyword defaults are the same as in the structure
  definition. This actually expands into a CREATE-<type> function call:

CREATE-<type> <name> &optional <slot> ...                        [Function]

  Creates an instance of structure type <type>, and indexes the instance
  under <name>.  No defaults are available on the slot arguments.  This
  is intended for 'internal' use by code: hence we trade off the con-
  venience of default values and keyword arguments for the efficiency of
  explicit  arguments.  The slot arguments are in the order they were
  given in DST, except that :computed slots have no argument.

INSTANCE FUNCTIONS AND MACROS:

  See documentation for COPIES, DESTROYS, GETS, and PRINTS.

TYPE ACCESS MACROS:

  For getting information about types, see COMPUTED-SLOTS, CREATOR,
  DEFINING-FORM, INITIAL-OFFSET,  INSTANCES, NAMED, READ-ONLY-SLOTS,
  REPRESENTATION, REUSABLE, SLOT-ACCESS, SLOT-DEFAULTS, SLOT-INFO,
  TYPE-INFO, and UNCOMPUTED-SLOTS. TYPE-INFO is setf-able.

GLOBAL OPERATIONS ON TYPES:

  See DESTROY-ALL-TYPES, DESTROY-TYPE, FLUSH-FREELIST, RESET-ALL-TYPES,
  and RESET-TYPE.  DST and DEFINE-TYPE can redefine an existing type.

|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Exercizes for the macho reader:
; 1. Play with :include option and get the code to handle it.
; 2. Ditto for :conc-name.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package 'SM :use '("LISP"))

(export '(
          *default-instance-file-path*
          *default-instance-file-type*
          *warn-of-redefinitions*

          ;; Defining
          dst
          define-type

          ;; For instances

      copies
          destroys
          gets
          prints

          ;; For types

          computed-slots
          creator
          defining-form
          destroy-type
          flush-freelist
          named
          initial-offset
          instances
          load-type
          read-only-slots
          representation
          reset-type
          reusable
          save-instances
          save-type
          slot-access
          slot-defaults
          slot-info
          slot-types
          type-info
          uncomputed-slots

          ;; For SM as a whole

          destroy-all-types
          reset-all-types
          structure-types
          ))

;;; The best default optimization for Coral Allegro and HP Common Lisp.
;;; Crank speed up to 3 once past argument checking.
(proclaim '(optimize (safety 1) (space 2) (speed 2)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                       INTERNAL DATA STRUCTURES
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *DEFAULT-INSTANCE-FILE-PATH*
    #+HP "$HOME/"
        #+:CCL "ccl;"
        #+VAX "sys$login:"
        #+TI   "*;"
        #-(or hp :ccl vax ti) ""
  "Directory where instance definitions are saved and loaded by default.")
(proclaim '(string *default-instance-file-path*))

(defparameter *DEFAULT-INSTANCE-FILE-TYPE*
    #+HP "l"
        #+:CCL "lisp"
        #+VAX "lsp"
        #+TI   "lisp"
        #-(or hp :ccl vax ti) "lsp"
  "Default extension for files instances are saved in and loaded from.")
(proclaim '(string *default-instance-file-type*))

#-TI (defparameter *KEYWORD-PACKAGE* (find-package "KEYWORD")) ; exists on TI
#-TI (proclaim '(package *keyword-package*))

(defparameter *SM-PACKAGE* (find-package "SM"))
(proclaim '(package *sm-package*))

;;; Each structure type has one of the following structure-type structures
;;; as its $structure-type$ property.

(defstruct (STRUCTURE-TYPE (:constructor
                            record-new-type
                            (reusable         slot-access     macro-access
                             uncomputed-slots computed-slots  read-only-slots
                             slot-defaults    slot-types      slot-info
                             representation   initial-offset  named
                             creator          defining-form   info)))

  ;; list of names of created instances
  (INSTANCE-NAMES    nil :type list)

  ;; Flag indicating whether the freelist is used, and the freelist of old
  ;; instance structures to reuse.
  (REUSABLE          nil :type symbol :read-only t)
  (FREELIST          nil :type list)

  ;; PRINTS drivers: ordered lists of (slotname . slotaccess) for all slots
  ;; and macro slots.  Also usable elsewhere to associate slot names to access.
  (SLOT-ACCESS       nil :type list   :read-only t)
  (MACRO-ACCESS      nil :type list   :read-only t)

  ;; Provided for other programs.  Uncomputed-slots is in original order,
  ;; so it is in order of arguments to create-<type>.
  (UNCOMPUTED-SLOTS  nil :type list   :read-only t)
  (COMPUTED-SLOTS    nil :type list   :read-only t)
  (READ-ONLY-SLOTS   nil :type list   :read-only t)
  (SLOT-DEFAULTS     nil :type list   :read-only t) ; ((<name> . <default>)*)
  (SLOT-TYPES        nil :type list   :read-only t) ; ((<name> . <type>)*)
  (SLOT-INFO         nil :type list   :read-only t) ; ((<name> . <alist>)*)
                                                      ; alist: user keys -> info
  ;; Record of standard defstruct options.
  (REPRESENTATION    nil :type T      :read-only t) ; nil, list, vector, (vector <type>)
  (INITIAL-OFFSET    0   :type fixnum :read-only t) ; valid only if above non-nil
  (NAMED             t   :type symbol :read-only t) ; T or nil

  ;; Create-<type> function name.
  (CREATOR           nil :type symbol :read-only t)

  ;; The body of the DST macro call, saved to write out to files, etc.
  (DEFINING-FORM     nil :type list :read-only t)

  ;; User may do anything with this slot.
  (INFO              nil)
  )

(defparameter *STRUCTURE-TYPES* nil) ; Names of defined struct types.
(proclaim '(list *structure-types*))

(defparameter *WARN-OF-REDEFINITIONS* T
  "Toggles whether DST and create-<type> print warnings on redefinitions.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                  MACROS FOR STRUCTURE TYPE ACCESS
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Type macros.  All exported macros except INFO access :read-only slots,
;;; so these are safe against illicit attempts at setf.  Type checking:
;;; CHECK-TYPE would be more appropriate but it would complicate and slow
;;; down the macros. THE does check interactively on some machines.

(defmacro COMPUTED-SLOTS (type)
  "computed-slots <type>                                               [Macro]
  Returns list of slot names which are computed for <type>.  These are
  NOT specifiable as arguments to create-<type> or the <type> macro."
  `(structure-type-computed-slots
    (the structure-type (get ,type '$structure-type$))))

(defmacro CREATOR (type)
  "creator <type>                                                      [Macro]
  Returns the name of the create-<type> function for <type>."
  `(structure-type-creator
    (the structure-type (get ,type '$structure-type$))))

(defmacro DEFINING-FORM (type)
  "defining-form <type>                                                [Macro]
  Returns the expression which defined the type."
  `(structure-type-defining-form
    (the structure-type (get ,type '$structure-type$))))

(defmacro FREELIST (type)
  ;; Writeable slot, not exported.  World doesn't need this.
  `(structure-type-freelist
    (the structure-type (get ,type '$structure-type$))))

(defmacro INITIAL-OFFSET (type)
  "initial-offset <type>                                               [Macro]
  Returns the value given to :initial-offset.  See also representation macro."
  `(structure-type-initial-offset
     (the structure-type (get ,type '$structure-type$))))

(defmacro INSTANCE-NAMES (type)
  ;; Writeable slot, so not exported.  World uses (instances <type>) instead.
  `(structure-type-instance-names
    (the structure-type (get ,type '$structure-type$))))

(defmacro MACRO-ACCESS (type)
  ;; Not exported.  World uses slot-access.
  `(structure-type-macro-access
    (the structure-type (get ,type '$structure-type$))))

(defmacro NAMED (type)
  "named     <type>                                                    [Macro]
  Returns T if <type> is represented with named structures, else NIL."
  `(structure-type-named
     (the structure-type (get ,type '$structure-type$))))

(defmacro READ-ONLY-SLOTS (type)
  "read-only-slots <type>                                              [Macro]
  Returns list of slot names which are :read-only for <type>."
  `(structure-type-read-only-slots
     (the structure-type (get ,type '$structure-type$))))

(defmacro REPRESENTATION (type)
  "representation <type>                                               [Macro]
  Returns NIL if the default structure representation was used, or LIST,
  VECTOR, or (VECTOR <element-type>) otherwise -- see CLtL p. 314."
  `(structure-type-representation
     (the structure-type (get ,type '$structure-type$))))

(defmacro REUSABLE (type)
  "reusable <type>                                                     [Macro]
  T iff memory of destroyed instances is reused for new instances of <type>."
  `(structure-type-reusable
    (the structure-type (get ,type '$structure-type$))))

(defmacro SLOT-ACCESS (type)
  "slot-access <type>                                                  [Macro]
  Returns a-list of (<slot-name> . <slot-access-function>) pairs for <type>."
  `(structure-type-slot-access
    (the structure-type (get ,type '$structure-type$))))

(defmacro SLOT-DEFAULTS (type)
  "slot-defaults <type>                                                [Macro]
  Returns a-list of (<slot-name> . <slot-default-expression>) pairs for <type>.
  NOTE that <slot-default-expression> must be EVALUTED to guarantee a correct
  value: this is an alist to the EXPRESSIONS which produce the defaults."
  `(structure-type-slot-defaults
    (the structure-type (get ,type '$structure-type$))))

(defmacro SLOT-INFO (type &optional slot keyword)
  "slot-info <type> &optional <slot> <keyword>                         [Macro]
  Access to an association list of slot names to info lists. Each info list
  is itself an association list of keywords to info.  That is, the top level
  list looks like:
    ((<slot-1> . ((<key> . <info>)*)) ... (<slot-N> . ((<key> . <info>)*)))
  where <key> is a user-supplied slot definition keyword, and <info> is the
  info which DST found after it.  The expansion depends on whether the
  optional arguments are given.  Without any of them, it returns the entire
  alist.  With <slot>, will return the result of CDR-ASSOCing the given <slot>
  into this list, that is: ((<key> . <info>)*).  With <slot> and <keyword>
  specified, returns the result of  CDR-ASSOCing <keyword> into the result of
  CDR-ASSOCing <slot>: <info>."
  (cond ((and slot keyword)
         `(cdr (assoc ,keyword
                      (cdr (assoc ,slot
                                  (structure-type-slot-info
                                   (the structure-type
                                        (get ,type '$structure-type$))))))))
        (slot
         `(cdr (assoc ,slot
                      (structure-type-slot-info
                       (the structure-type (get ,type '$structure-type$))))))
        (T
         `(structure-type-slot-info
           (the structure-type (get ,type '$structure-type$))))))

(defmacro SLOT-TYPES (type)
  "slot-types <type>                                                   [Macro]
  Returns a-list of (<slot-name> . <slot-type>) pairs for <type>."
  `(structure-type-slot-types
    (the structure-type (get ,type '$structure-type$))))

(defmacro TYPE-INFO (type &optional keyword)
  "type-info <type> &optional keyword                                  [Macro]
  Access to an association list of keywords to information for the type,
  which looks like: ((<key-1> . <info>) ... (<key-N> . <info>)), where
  <key> is a user-supplied type option keyword, and <info> is whatever
  DST found after it.  The expansion depends on whether the optional
  argument is given.  Without the optional argument, it returns the
  entire alist.  With <keyword>, will return the result of CDR-ASSOCing
  the given <keyword> into this list, that is: <info>.  Setf works."
  (if keyword
    `(cdr (assoc ,keyword
                 (structure-type-info
                  (the structure-type (get ,type '$structure-type$)))))
    `(structure-type-info
      (the structure-type (get ,type '$structure-type$)))))

(defmacro UNCOMPUTED-SLOTS (type)
  "uncomputed-slots <type>                                             [Macro]
  Returns list of slot names which are not computed for <type>.  This
  is in the same order as the arguments to the function create-<type>."
  `(structure-type-uncomputed-slots
    (the structure-type (get ,type '$structure-type$))))

;;;--------------------------------------------------------
;;; Instance access.  For efficiency, we'll have to trust them on the setf.

(defmacro GETS (type name)
  "gets <type> <name>                                                  [Macro]
  Retrieves the representation an instance of <type> called <name>.
  Defstruct functions may be used on the result.  Do not SETF this!"
  `(get (the symbol ,name) (the symbol ,type)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                         INSTANCE FUNCTIONS
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun INSTANCES (type) ; a function to prevent user setfs
  "instances <type>                                                 [Function]
  Returns a list of all the names of struct instances of <type>."
  (check-type type symbol)
  (assert (get type '$structure-type$) (type) "Type is not known.")
  (instance-names type))
(proclaim '(function instances (symbol) list))

;;; Copying is fraught with difficulties: Common Lisp provides no generic
;;; copy function; attempting to copy a circular object will result in an
;;; infinite loop or stack overflow; and some objects have no copy function.
;;; The notion of a 'copy' is ill defined. Should sublists be copied? If so,
;;; how are circularities preserved? Should copy-symbol be used?
;;; For these reasons, I don't attempt to do more than copy-tree of conses.

(defun COPIES (type source target &key (copy-tree t))
  "copies <type> <source> <target> &key (copy-tree t)               [Function]
  Creates a copy of instance <source> whose name is <target>.  If <target>
  already exists, it will be destroyed first.  Returns <target>. If
  :copy-tree is T (the default), any slot value which is a cons is copied
  with copy-tree. Otherwise, the slot values of the copied instance are the
  same memory objects as those of the original.  To attempt to guarantee
  that memory is not shared, evaluate the macro representation of the
  instance and recompute its computed slots."
  (check-type type   symbol)
  (check-type source symbol)
  (check-type target symbol)
  (assert (gets type source) (type source) "Unknown type or source instance name.")
  (let ((slots->access (slot-access type))
    (source-struct (gets type source)))
    (declare (list slots->access) (optimize (safety 1) (space 2) (speed 3)))
    (when (gets type target)
      (if *warn-of-redefinitions*
      (warn "~%[SM:COPYS] ~S of type ~S being redefined to be a copy of ~S"
        target type source))
      (destroys type target))
    ;; Create the instance, with correct :uncomputed slots (including :read-only)
    (apply (creator type)
       target
       (mapcar #'(lambda (uslot)
               (declare (symbol uslot))
                       (let ((val (funcall (cdr (assoc uslot slots->access))
                                             source-struct)))
                           (if (and copy-tree (consp val)) (copy-tree val) val)))
           (uncomputed-slots type)))
    ;; Copy :computed slots in.
    (dolist (cslot (computed-slots type))
      (eval `(setf (,(cdr (assoc cslot slots->access)) ',(gets type target))
                   (let ((val (,(cdr (assoc cslot slots->access)) ',source-struct)))
                     (if (and ',copy-tree (consp val)) (copy-tree val) val)))))
    target))

;;; In the process of unassociating the struct with the <name>, this
;;; function saves the struct on a free list so it may be reused to
;;; create future instances.  Use DESTROY-TYPE to free up space for GC.

(defun DESTROYS (type name)
  "destroys <type> <name>                                           [Function]
  Destroys the <name> struct instance of <type>.  If (reusable type),
  instance memory is saved for reuse when new instances are allocated.
  Use FLUSH-FREELIST or DESTROY-TYPE to reclaim the freelist."
  (check-type type symbol)
  (check-type name symbol)
  (assert (gets type name) (type name) "Unknown type or instance name.")
  (setf (instance-names type)
        (delete name (the list (instance-names type))))
  ;; Save only if reusable, and this thing was not clobbered already.
  (if (and (reusable type) (get name type))
      (push (get name type) (freelist type)))
  (remprop name type)
  name)
(proclaim '(function destroys (symbol symbol) symbol))

(defun PRINTS (type name &key (stream *standard-output*)
                    (style :brief) (omit nil))
  "prints <type> <name> &key :stream :style :omit                   [Function]
  Prints a <type> instance called <name>.  Keyword arg :stream defaults to
  T.  The :style is one of:
    :name         -- prints <<type> <name>>
    :brief        -- prints uncomputed slots with length and depth cutoff, ~A
    :summary      -- prints all slots, less stringent cutoff than :brief, uses ~S
    :pretty       -- all slots printed, no cutoff, *print-pretty* t, ~A
    :macro        -- re-readable form (no uncomputed slots), one slot per line
    :pretty-macro -- like :macro but pretty printed (multiple lines per slot)
    :list-macro   -- like :macro but a list rather than string is returned,
                     and no printing is done (<stream> is ignored).
  Default is :brief.  Pretty forms print slowly.  Argument :omit is a list of
  slot names; these slots are not printed."
  (check-type type   symbol)
  (check-type name   symbol)
  (check-type style  (member :name :brief :summary :pretty
                             :macro :pretty-macro :list-macro))
  (check-type stream (or null simple-string stream))
  (check-type omit   list)
  (assert (gets type name) (type name) "Unknown type or instance name.")
  (let* ((struct (gets type name))
         (newlinestring (format nil "~% "))
         (newline (char newlinestring 0)))
    (declare (type structure-type struct)
             (simple-string newlinestring)
             (character newline))
    (case style
      ((:name)
       (let ((*print-case* :capitalize))
         (format stream "<~A ~A>" type name)))
      ((:brief)
       (let ((*print-pretty* t) (*print-escape* nil) (*print-circle* t)
             (*print-case* :capitalize) (*print-array* nil)
             (*print-level* 2) (*print-length* 3)
             #+:ccl (ccl::*print-structure* nil)
             )
         ;; Speed optimized in here since we are past the crucial argument
         ;; checks, and the printer is slow.
         (declare (optimize (safety 1) (space 2) (speed 3)))
         (format stream "[~A ~A:~{~& ~A: ~(~S~)~}]" type name
                 (mapcan #'(lambda (slot+access)
                             (declare (cons slot+access))
                             (unless (member (car slot+access) omit)
                               (list (car slot+access)
                                     (funcall (cdr slot+access) struct))))
                         (the list (macro-access type))))))
      ((:summary)
       (let ((*print-pretty* t) (*print-escape* nil) (*print-circle* t)
             (*print-case* :capitalize) (*print-array* nil)
             (*print-level* 3) (*print-length* 10)
             #+:ccl (ccl::*print-structure* nil)
             )
         (declare (optimize (safety 1) (space 2) (speed 3)))
         (format stream "[~S ~S:~{~& ~A: ~15,5T~(~S~)~}]" type name
                 (mapcan #'(lambda (slot+access)
                             (declare (cons slot+access))
                             (unless (member (car slot+access) omit)
                               (list (car slot+access)
                                     (funcall (cdr slot+access) struct))))
                         (the list (slot-access type))))))
      ((:pretty)
       (let ((*print-pretty* t) (*print-escape* nil) (*print-circle* t)
             (*print-case* :capitalize) (*print-array* nil)
             #+:ccl (ccl::*print-structure* nil)
             )
         (declare (optimize (safety 1) (space 2) (speed 3)))
         (format stream "[~S ~S:~{~& ~A: ~15,5T~(~A~)~}]" type name
                 (mapcan #'(lambda (slot+access)
                             (declare (cons slot+access))
                             (unless (member (car slot+access) omit)
                               (list (car slot+access)
                                     ;; Allegro CL did not pretty print format.
                                     ;; Also want newline if it is a big object.
                                     (let* ((*print-case* :downcase)
                                            (s (princ-to-string
                                                (funcall (cdr slot+access) struct))))
                                       (declare (string s))
                                       (if (find newline s)
                                         (concatenate 'string newlinestring s)
                                         s)))))
                         (the list (slot-access type))))))
      ((:macro)
       (let ((*print-pretty* nil) (*print-escape* t) (*print-circle* nil)
             (*print-case* :upcase) (*print-array* t)
             #+:ccl (ccl::*print-structure* t)
             )
         (declare (optimize (safety 1) (space 2) (speed 3)))
         (format stream "(~S ~S~{~& :~A ~S~})" type name
                 (mapcan #'(lambda (slot+access)
                             (declare (cons slot+access))
                             (unless (member (car slot+access) omit)
                               (list (car slot+access)
                                     (funcall (cdr slot+access) struct))))
                         (the list (macro-access type))))))
      ((:pretty-macro)
       (let ((*print-pretty* t) (*print-escape* t) (*print-circle* nil)
             (*print-case* :upcase) (*print-array* t)
             #+:ccl (ccl::*print-structure* t)
             )
         (declare (optimize (safety 1) (space 2) (speed 3)))
         (format stream "(~S ~S~{~& :~A ~20,5T~A~})" type name
                 (mapcan #'(lambda (slot+access)
                             (declare (cons slot+access))
                             (unless (member (car slot+access) omit)
                               (let* ((*print-case* :downcase)
                                      (s (prin1-to-string
                                          (funcall (cdr slot+access) struct))))
                                 (declare (string s))
                                 (list (car slot+access)
                                       (if (find newline s)
                                         (concatenate  'string newlinestring s)
                                         s)))))
                         (the list (macro-access type))))))
      ((:list-macro)
       `(,type ,name
               ,.(mapcan #'(lambda (slot+access)
                             (declare (cons slot+access))
                             (unless (member (car slot+access) omit)
                               (list (intern (symbol-name (car slot+access))
                                             *keyword-package*)
                                     (funcall (cdr slot+access) struct))))
                         (the list (macro-access type))))))))
(proclaim '(function prints (symbol symbol &key stream keyword list) t))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                          TYPE FUNCTIONS
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun STRUCTURE-TYPES () ; This remains a function to prevent user setfs.
 "structure-types                                                   [Function]
  Returns a list of defined structure types."
  *structure-types*)
(proclaim '(function structure-types () list))

(defun RESET-TYPE (type)
  "reset-type <type>                                                [Function]
  Destroys all instances of <type>.  If (reusable type), instance
  memory is saved for reuse when new instances are allocated."
  (check-type type symbol)
  (assert (get type '$structure-type$) (type) "Type is not known.")
  (if (reusable type)
      (dolist (name (instance-names type))
        (declare (symbol name))
        (if (get name type)
            (push (get name type) (freelist type)))
        (remprop name type))
      (dolist (name (instance-names type))
        (declare (symbol name))
        (remprop name type)))
  (setf (instance-names type) nil)
  type)
(proclaim '(function reset-type (symbol) symbol))

;;; This function removes all references to the storage taken up by
;;; instances within SM, so if no other references exists, the space
;;; will be reclaimed by GC.

(defun FLUSH-FREELIST (type)
  "flush-freelist <type>                                            [Function]
  Empties the freelist of <type>, making that storage available for
  garbage collection."
  (check-type type symbol)
  (assert (get type '$structure-type$) (type) "Type is not known.")
  (setf (freelist type) nil))
(proclaim '(function flush-freelist (symbol) null))

(defun DESTROY-TYPE (type)
  "destroy-type <type>                                              [Function]
  Destroys all instances of <type>, and then undefines the <type>."
  (check-type type symbol)
  (assert (get type '$structure-type$) (type) "Type is not known.")
  (dolist (instance (instance-names type))
    (declare (symbol instance))
    (remprop instance type))
  ;; About to mess with the type definition, so make it unofficial.
  (setf *structure-types* (delete type *structure-types*))
  ;; Undefine the functions.  This helps redefinitions behave right.
  (fmakunbound type)
  (fmakunbound (creator type))
  (dolist (slot+access (slot-access type))
    (fmakunbound (cdr slot+access)))
  ;; This has to be last since we access property in getting above info.
  (remprop type '$structure-type$)
  type)
(proclaim '(function destroy-type (symbol) symbol))

(defun RESET-ALL-TYPES ()
  "reset-all-types                                                  [Function]
  Destroys all instances in SM, but leaves type definitions intact."
  (dolist (type *structure-types*)
    (declare (symbol type))
    (reset-type type)))
(proclaim '(function reset-all-types () null))

(defun DESTROY-ALL-TYPES ()
  "destroy-all-types                                                [Function]
  DESTROYS all instances, and undefines all types, leaving SM in the state
  it was in when intitially loaded (though not common lisp)."
  (dolist (type (copy-tree *structure-types*)) ; list is modified below.
    (declare (symbol type))
    (destroy-type type)))
(proclaim '(function destroy-all-types () null))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                              TYPE DEFINITION
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; First we start with some helpers for defining DST and DEFINE-TYPE.
;;; These use numerous symbols in the lexical environment the expansion sees.

(eval-when (compile eval)

  (defmacro MAKE-NAMES-OF-THINGS ()
    '(progn
       (if (atom type-and-options)
         (setf type-and-options (list type-and-options))) ; For uniformity
       (setq type        (first type-and-options))
       (setq type-string (symbol-name type))
       (setq creator (intern (concatenate 'string "CREATE-" type-string)
                             *package*))
       (setq maker   (intern (concatenate 'string "SM$ALLOCATE-" type-string)
                             *package*)))) ; because if in SM, may collide!

  (defmacro PROCESS-SLOT-DEFINITIONS (calling-function-name)
    ;; Loop to process the slot-definitions, constructing defstruct canonical form
    ;; and recording slot definition information.
    `(do ((sdptr slot-definitions (rest sdptr))
          (sdef nil) (sname nil) (sdefault) (stype nil) (sread-only nil)
          (saccess nil) (scomputed nil) (sinfo nil))
         ((null sdptr)
          (progn
            ;; Knock off :heads.
            (pop read-only-slots)
            (pop computed-slots)
            (pop uncomputed-slots)
            (pop defstruct-slot-definitions)
            (pop slot-defaults)
            (pop slot-info)
            (pop slot-types)
            (pop slot-access)
            (pop macro-access)))
       (declare (list sdptr sdef sinfo)
                (symbol sname saccess sread-only scomputed))

       ;; Change atomic slot definitions to (<slot> nil) for uniformity.
       (setq sdef
             (if (atom (first sdptr)) (list (first sdptr) nil) (first sdptr)))

       ;; Get or create all standard slot information.
       ;; Create <type>-<slot> slot access symbol in calling package.
       (setf sname      (first sdef))
       (setf sdefault   (second sdef))
       (setf stype      (or (second (member :type sdef)) T))
       (setf sread-only (second (member :read-only sdef)))
       (setf scomputed  (second (member :computed  sdef)))
       (setf saccess    (intern (concatenate 'string type-string "-"
                                             (symbol-name sname))
                                *package*))

       ;; Record defstruct version of the slot definition.
       (nconc defstruct-slot-definitions
              (list (list sname sdefault :type stype :read-only sread-only)))

       ;; Record the slot's information on appropriate association lists.
       (nconc slot-defaults (list (cons sname sdefault)))
       (nconc slot-types    (list (cons sname stype)))
       (nconc slot-access   (list (cons sname saccess)))
       (when sread-only
         (if scomputed
           (error ,(concatenate 'string
                                "[SM:"
                                calling-function-name
                                "] ~S Computed slot cannot be read only: ~S")
                  type sdef))
         (setf reusable nil)
         (nconc read-only-slots (list sname)))
       (if scomputed
         (nconc computed-slots (list sname))
         (progn
           ;; Subset of slot-access; used to drive printer.
           (nconc macro-access (list (cons sname saccess)))
           ;; Retain order to be same as create-<type> args.
           (nconc uncomputed-slots (list sname))))

       ;; Find and record all non-standard slot options by searching from
       ;; after the name and default.
       (setf sinfo (cons sname nil))
       (do ((opt-ptr (cddr sdef) (cddr opt-ptr)))
           ((null opt-ptr))
         (declare (list opt-ptr))
         (if (not (member (first opt-ptr) '(:type :read-only :computed)))
           (push (cons (first opt-ptr) (second opt-ptr))
                 (cdr sinfo))))
       (nconc slot-info (list sinfo))))

  (defmacro PROCESS-TYPE-DEFINITION (calling-function-name)
    `(flet ((find-spec (key specs)
                       (declare (keyword key) (list specs))
                       (if (eq key :named)
                         (if (member :named (cdr specs)) :named)
                         (first (member key (cdr specs)
                                        :key #'(lambda (el)
                                                 (if (listp el) (first el) nil)))))))
       ;; Get all standard type information.
       ;; Need to distinguish a given NIL from a non-given spec.
       (let ((comments-spec       (find-spec :comments       type-and-options))
             (initial-offset-spec (find-spec :initial-offset type-and-options))
             (named-spec          (find-spec :named          type-and-options))
             (predicate-spec      (find-spec :predicate      type-and-options))
             (print-function-spec (find-spec :print-function type-and-options))
             (reusable-spec       (find-spec :reusable       type-and-options))
             (redefine-spec       (find-spec :redefine       type-and-options))
             (sort-instances-spec (find-spec :sort-instances type-and-options))
             (type-spec           (find-spec :type           type-and-options)))
         (declare (list comments-spec initial-offset-spec predicate-spec
                        print-function-spec reusable-spec redefine-spec
                        sort-instances-spec type-spec)
                  (symbol named-spec))

         ;; Check for consistency of :reusable specification with slot :read-only.
         ;; If consistent and they asked for reusable, honor it.
         (cond ((and reusable-spec (second reusable-spec) (not reusable))
                (error
                 ,(concatenate 'string
                               "[SM:"
                               calling-function-name
                               "] ~S :reusable T incompatible with :read-only slot")
                 type))
               ((and reusable-spec (not (second reusable-spec)))
                (setf reusable nil)))

         ;; Record comments, redefine and sort-instances.
         (if comments-spec       (setf documentation  (second comments-spec)))
         (if redefine-spec       (setf redefine       (second redefine-spec)))
         (if sort-instances-spec (setf sort-instances (second sort-instances-spec)))

         ;; Check consistency of and record representation specifications.
         (cond  (type-spec
                 (setf representation (second type-spec))
                 (if initial-offset-spec
                   (setf initial-offset (second initial-offset-spec)))
                 (if named-spec (setf named t) (setf named nil)))
                ((or initial-offset-spec named-spec)
                 (error
                  ,(concatenate 'string
                                "[SM:"
                                calling-function-name
                                "] ~S :initial-offset and :named cannot be given without :type.")
                  type)))

         ;; Construct the defstruct version, using permitted options if asked for.
         ;; Add :constructor option for faster BOA constructor (see p. 315 CLtL).
         ;; Keywords not needed since user never calls allocate-<type>.  Defaults
         ;; not needed since create-<type> will supply them.
         (setf defstruct-type-and-options
               `(,type
                 ,(list :constructor maker
                        (mapcar #'car defstruct-slot-definitions))
                 ,.(if predicate-spec      (list predicate-spec))
                 ,.(if print-function-spec (list print-function-spec))
                 ,.(if type-spec           (list type-spec))
                 ,.(if named-spec          (list named-spec))
                 ,.(if initial-offset-spec (list initial-offset-spec))))

         ;; Find and record user extensions to type options.
         (do ((opt-ptr (cdr type-and-options) (cdr opt-ptr)))
             ((null opt-ptr))
           (declare (list opt-ptr))
           (cond ((atom (car opt-ptr))
                  (if (not (eq (car opt-ptr) :named))
                    (error
                     ,(concatenate 'string
                                   "[SM:"
                                   calling-function-name
                                   "] ~S has bad type option ~S.")
                     type (car opt-ptr))))
                 ((not (member (caar opt-ptr)
                               '(:reusable :redefine :sort-instances :predicate
                                 :print-function :type :initial-offset)))
                  (push (cons (caar opt-ptr) (cadar opt-ptr)) type-info)))))))

  ) ; end of eval-when

(defvar *SAVED-INSTANCES* nil
  "DEFINE-TYPE saves macro representations of all instances of a type being
  redefined on this global before destroying the type.  While this is normally
  for internal use only, it is exported in case there is an error during the
  redefinition, and the user wishes to recover the instances.")
(proclaim '(list *saved-instances*))

(defun SAVE-INSTANCES (type new-computed-slots new-uncomputed-slots)
  ;; Save on *saved-instances* evaluatable macro representations of instances
  ;; using the print function on the old type.
  (declare (symbol type) (special *saved-instances*))
  (dolist (r (instances type))
    (declare (symbol r))
    (push (prints type r
                  :style :list-macro
                  :omit
                  ;; Omit all slots computed in the new type, and all slots
                  ;; which were uncomputed in the old but are being deleted.
                  (union new-computed-slots
                         (set-difference (uncomputed-slots type)
                                         (union new-computed-slots
                                                new-uncomputed-slots))))
          *saved-instances*))

  ;; Slots which are now computed but will be uncomputed can have their values
  ;; defined in the new instances.  Need to add explicitly since prints of the
  ;; old type won't get them there.
  (dolist (slot (intersection (computed-slots type) new-uncomputed-slots))
    (declare (symbol slot))
    (dolist (irep *saved-instances*)
      (declare (list irep))
      (nconc irep (list (intern (symbol-name slot) *keyword-package*)
                        (funcall (cdr (assoc slot (slot-access type)))
                                 (gets type (second irep)))))))
  type)

(defun RESTORE-INSTANCES ()
  ;; There will be a lot of redefinitions, and we already warned if it was T.
  (let ((*warn-of-redefinitions* nil))
    (loop
      (if (null *saved-instances*) (return))
      (eval (pop *saved-instances*)))))

(defmacro INSERT-IN-SORTED-LIST (element list-place)
  `(let ((element-name (symbol-name ,element)))
     (declare (string element-name) (optimize (safety 1) (space 2) (speed 3)))
     (cond ((null ,list-place)
            (setf ,list-place (list ,element)))
           ((string< element-name (symbol-name (first ,list-place)))
            (push ,element ,list-place))
           (T
            ;; Invariant: (first lptr) always < element.  Looking to insert after.
            (do ((lptr ,list-place (cdr lptr))
                 (successp nil))
                ((or successp (null (cdr lptr)))
                 (if (not successp)
                   (nconc ,list-place (list ,element))
                   ,list-place))
              (declare (list lptr))
              (when (string< element-name (symbol-name (second lptr)))
                (setf (cdr lptr) (cons ,element (cdr lptr)))
                (setf successp t)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This macro expands into a single progn containing all needed definitions.
;;; (The function and macro definitions in a progn are compiled.)  This is
;;; truly a "hairy macro". It works in two parts: cooking the arguments,
;;; and generating the expansion.  You are advised to use macroexpand to
;;; thoroughly understand this macro before attempting to change it.

(defmacro DST (&whole defining-form
                      type-and-options
                      &rest slot-definitions
                      &aux
                           defstruct-type-and-options  ; Defstruct versions
                           (defstruct-slot-definitions ;   (sans extra specs).
                            (list :head))              ;
                           type                        ; symbol name of type
                           (type-string "")            ; string name of type
                           (documentation nil)         ; from :comments spec
                           (reusable T)                ; will update this
                           (redefine nil)              ;
                           (sort-instances nil)        ; whether sort code generated.
                           (initial-offset 0)          ; type options
                           (representation nil)
                           (named T)
                           (type-info nil)             ; ((key . info)*)
                           ;; :Head for nconc to preserve order user gave, in some
                           ;; cases so create-<type> has right argument order, but
                           ;; for alists it is for efficiency since presumably the
                           ;; most used slots are given first.
                           (slot-access      (list :head)) ; ((name . access)*)
                           (macro-access     (list :head)) ; ditto, uncomputed only
                           (read-only-slots  (list :head))
                           (computed-slots   (list :head))
                           (uncomputed-slots (list :head))
                           (slot-defaults (list :head)); ((name . default)*)
                           (slot-types (list :head))   ; ((name . type)*)
                           (slot-info (list :head))    ; ((name . ((key . info)*))*)
                           creator                     ; create-<type>
                           maker                       ; make-<type>
                           )

  "DST <type-and-options>  <slot-spec>*                                [Macro]

  Defines a common lisp structure type, and supporting Structure Manager
  code.  Syntax is nearly identical to that of defstruct, except as noted:

  <type-and-options> ::= <type>    |  ( <type> <type-option>* )
  <type>             ::= <symbol>
  <type-option>      ::= :named    |  ( <keyword> <argument> )
  <slot-spec>        ::= <symbol>  |  ( <symbol> <default> <slot-option>* )
  <slot-option>      ::= <keyword> <argument>

  This macro will:
    1. Check for existing definition of <type> and destroy or redefine
       it as directed by the :redefine type option (described below);
    2. Define the common lisp structure for instances of <type>;
    3. Record the new type definition in SM data structures;
    4. Define create-<type> function to create instances; and
    5. Define <type> macro for no-eval creation of instances.
  All symbols defined by DST are defined in the calling package.

  Notes on Type Options:

    :CONC-NAME      - NOT allowed. Code assumes default in various places.
    :CONSTRUCTOR    - NOT allowed.  Use create-<type>.
    :COPIER         - NOT allowed.  Use COPIES.
    :INCLUDE        - NOT allowed. Possible but would take a major revision.
    :PREDICATE      - OK to use option.  You can apply it to result of GETS.
      However, in most cases, (gets 'type name) suffices as a predicate.
    :PRINT-FUNCTION - OK to use (SM doesn't use this).  Will only affect
      printing of structures in things like error messages and traces.
    :TYPE, :NAMED, :INITIAL-OFFSET - Probably OK to use.

    :COMMENTS - String; will be recorded as the type's documentation.

    :REUSABLE - A new type option.  When T, storage for structures is to
      be reused. Default T unless a slot is :read-only. If ANY slot has
      :read-only T, it is an error for :reusable to be T (as the slot
      cannot be reassigned for new instances).

    :REDEFINE - Syntactically, a new type option, but semantically this
      option is associated solely with the particular invocation of DST,
      and indicates whether that invocation should redefine or destroy
      an existing type of the same name, if found. When T, defining an
      existing type results in redefinition of the type, with any existing
      instances re-represented as instances of the new type.  Existing
      instances will be converted to the new representation if possible.
      It is always possible to reorder, add, or delete slots, and to extend
      the range of their types.  Restricting their types is only possible
      if all of the existing instances meet the new type restriction.  New
      slots will be initialized to default values. When NIL (default),
      redefinition will result in destruction of the existing type and
      instances first. :Redefine makes the most sense with DEFINE-TYPE.
      Interacts with *warn-of-redefinitions* as follows:

                   | Redefine T        | Redefine nil
      -------------|-------------------|-------------------------------------
      Warnings off | Redefine silently | Destroy silently
      -------------|-------------------|-------------------------------------
      Warnings on  | Redefine and Warn | If instances exist, Cerror continued
                   |                   | with Destroy; Else Destroy and Warn
      -------------|-------------------|-------------------------------------

    :SORT-INSTANCES - A new type option.  Default NIL: If T, the instance
      creation function will ensure that (instances '<type>) always returns
      a list sorted by symbol name.  Slows down instance creation.

    :<ANYTHING> - Type options may be extended arbitrarily by the user.
      Any keyword-argument list whose keyword is not one of the above will
      be added to the association list accessible in TYPE-INFO.  For example:
        (dst (MY-TYPE (:reusable T) (:specializes more-general-type)) ...)
      results in a TYPE-INFO of ((:specializes more-general-type)).

  Notes on Slot Options:

    :READ-ONLY - OK to use.  See :reusable.  Incompatible with :computed.
    :TYPE      - OK to use, and I highly recommend it (see SLOT-TYPES).

    :COMPUTED - A new slot option.  When T, SM assumes the contents of
      the slot are always computed at run time.  Therefore, the slot is
      not printed in macro representations of instances, and there is no
      corresponding argument to create-<type> or <type> macro.  Default nil.

    :<ANYTHING> - Slot options may be extended arbitrarily by the user.
      Any keyword-argument pair whose keyword is not one of the above slot
      options will be recorded.  For example:
        (my-slot nil :type list :computed t :if-needed (lambda () ...))
      SLOT-INFO returns an association list of slot names to nested alists
      of keywords to arguments.  For example, slot-info will have:
        (... (my-slot . (:if-needed . (lambda () ...))) ...)

  About slot-defaults:

  For various technical reasons, the <default> expressions are NOT evaluated until
  the time at which a default is needed.  For this reason, these expressions should
  not incur side effects.  Nor should they depend on the current environment (unless
  you wish to change the default as a function of environment).

  To be safe, only use DST at top level.  Use the function DEFINE-TYPE for
  non-top-level definitions."

  (declare (symbol type reusable redefine creator maker)
           (simple-string type-string)
           (list defining-form slot-definitions defstruct-type-and-options
                 defstruct-slot-definitions type-info slot-access macro-access
                 read-only-slots computed-slots uncomputed-slots
                 slot-defaults slot-info slot-types))

  ;; ------------------------------------------------------------------------
  ;; The first section sets up various lists used to construct the expansion,
  ;; and saved in the structure-type structure.  None of this depends on the
  ;; run time environment (it can be done at compile time).
  ;; ------------------------------------------------------------------------

  (make-names-of-things)
  (process-slot-definitions "DST")
  (process-type-definition  "DST")

  ;; ------------------------------------------------------------------------
  ;; The expanded form begins with progn, to make all definitions top level.
  ;; ------------------------------------------------------------------------

  `(progn

     ;; If this is a redefinition, make sure all the instances of the type
     ;; are disposed or saved, checking with or warning user as as appropriate.
     ;; Why important: Create-<type> checks for redefinition of an instance
     ;; by testing the <type> property of the instance name, instead of the
     ;; slower member test of instance names.  If the instance exists, its
     ;; name is not added to the name list.  Thus, if these properties are
     ;; not reset upon type redefinition, instances which are not on the
     ;; instance name list will appear to exist, and will erroneously not be
     ;; placed on the instance list.  A destroy-type call avoids this.

     (when (member ',type *structure-types*)
       ,.(if redefine
          (list
           (list 'save-instances
                 (list 'quote type)
                 (list 'quote computed-slots)    ; Save-instances can access the
                 (list 'quote uncomputed-slots)) ; existing counterparts of these.
           (list 'when '*warn-of-redefinitions*
                 (list 'warn
                       (list 'format nil
                             "~%[SM:DST] ~S being redefined. ~A"
                             (list 'quote type)
                             (list 'if (list 'instances (list 'quote type))
                                   "Instances temporarily saved on
*saved-instances*, and will be redefined as instances of the new type."
                                   "(There were no instances.)"))))
           (list 'destroy-type (list 'quote type)))
          (list
           (list 'if '*warn-of-redefinitions*
                 (list 'if (list 'instances (list 'quote type))
                       ;; User may want to save in-memory instances first.
                       (list 'cerror
                             "Will proceed, calling DESTROY-TYPE first."
                             (concatenate
                              'string
                              "~%[SM:DST] Type " (symbol-name type)
                              " is defined, and has in-memory instances which~
                               ~%would be destroyed by redefinition."))
                       (list 'warn
                             (concatenate
                              'string
                              "~%[SM:DST] Type "
                              (symbol-name type)
                              " is being redefined (there were no instances)."))))
           (list 'destroy-type (list 'quote type)))))

     ;; Define instance structure.

     (defstruct ,defstruct-type-and-options
       ,.(if documentation (list documentation))
       ,.defstruct-slot-definitions)

     ;; Create a type structure for the new type, and record the name.

     (setf (get ',type '$structure-type$)
           (record-new-type
            ,reusable          ',slot-access    ',macro-access
            ',uncomputed-slots ',computed-slots ',read-only-slots
            ',slot-defaults    ',slot-types     ',slot-info
            ',representation   ',initial-offset ',named
            ',creator
        ;; Had a PDL overflow problem.  Apparently trying to save conses
        ;; by sharing.  We are saving the original macro call body in
        ;; a structure, which means that the expansion will have the
        ;; original form in it. Blew up in SUBLIS*, which tried to expand
        ;; the QUOTED call body when it found it in the expansion!
        ',#+TI (copy-list defining-form)
          #-TI defining-form
          ',type-info))
     (setq *structure-types*
           (sort (pushnew ',type *structure-types*)
                 #'(lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2)))))

     ;; Define instance creator, intended for internal use so args are not
     ;; keyworded, and are evaluated.  Computed slots have NO argument.
     ;;
     ;; (defun CREATE-<type> (name &optional (<slotname> <default>)...)
     ;;  "(CREATE-<type> name <slotname> ...)
     ;;  [Function] The slot arguments include only noncomputed slots.  Creates and
     ;;  records an instance of <type> ..."

     (defun ,creator
            (%name%
             &optional ,.(mapcar #'(lambda (s)
                                     (declare (symbol s))
                                     (list s (cdr (assoc s slot-defaults))))
                                 uncomputed-slots))
       ,(concatenate 'string
                     "CREATE-" type-string " <name> &optional"
                     (let ((*print-case* :downcase))
                       (format nil "~{ ~(<~A>~)~})" uncomputed-slots))
                     " [Function]
  The slot arguments include only uncomputed slots.  Creates and records
  an instance of " type-string " indexed by <name>."
                     (if sort-instances
                       "
  The list of instance names returned by INSTANCES is kept sorted."
                       ""))

       ;; Type declarations.
       (declare (symbol %name%)
                ,.(mapcar #'(lambda (s)
                              (list 'type (cdr (assoc s slot-types)) s))
                          uncomputed-slots)
                (optimize (safety 1) (space 2) (speed 3)))

       ;; Warn of redefinition if warnings not disabled.
       ;; NOTE that the existance test relies on proper disposal of destroyed
       ;; instances, to avoid the significantly slower test:
       ;;   (member name (structure-type-instances type-struct))
       ;; That is, this code relies on the <type> property of the instance name
       ;; symbol being destroyed when the instance is.

       (when (get %name% ',type)
         (if *warn-of-redefinitions*
           (warn ,(concatenate 'string
                               "~%[CREATE-" type-string "] Redefining instance ~A")
                 %name%))
         (destroys ',type %name%))

       ;; Creation of instance structure depends on whether the type is reusable.
       ;; For reusable types, the expansion will be of the form:
       ;;
       ;; (let* ((struct ; look on freelist and reuse if possible
       ;;          (if (freelist '<type>)
       ;;            (let ((old-struct (pop (freelist '<type>))))
       ;;              ;; Uncomputed slots are copied ...
       ;;              (setf (<type>-<slotname> old-struct) <slotname>)
       ;;               . . .
       ;;              ;; Computed slots are set to default ...
       ;;              (setf (<type>-<computed-slotname> old-struct) <initial-value>)
       ;;               . . .
       ;;              old-struct)
       ;;            (allocate-<type> <slotname-or-default> ...)))) ...)
       ;;
       ;; For UNreusable types:
       ;;
       ;; (let* ((struct (allocate-<type> <slotname-or-default> ...))) ...)
       ;;

       (let*
         ((struct
           ,(if reusable
              (list 'if (list 'freelist (list 'quote type))
                    (cons
                     'let
                     (cons
                      (list (list 'old-struct (list 'pop (list 'freelist
                                                               (list 'quote type)))))
                      (append (mapcar           ; copy value of uncomputed slots
                               #'(lambda (s+a)
                                   (declare (cons s+a))
                                   (list 'setf
                                         (list (cdr s+a) 'old-struct)
                                         (car s+a)))
                               macro-access)
                              (mapcar           ; set default of computed slots
                               #'(lambda (s)
                                   (declare (symbol s))
                                   (list 'setf
                                         (list (cdr (assoc s slot-access))
                                               'old-struct)
                                         (cdr (assoc s slot-defaults))))
                               computed-slots)
                              '(old-struct))))
                    (cons maker
                          (mapcar
                           #'(lambda (sd)
                               (declare (list sd))
                               ;; use default value if computed (not provided as arg)
                               (if (member (first sd) computed-slots)
                                 (list 'quote (cdr (assoc (first sd) slot-defaults)))
                                 (first sd)))
                           defstruct-slot-definitions)))
              (cons maker
                    (mapcar
                     #'(lambda (sd)
                         (declare (list sd))
                         (if (member (first sd) computed-slots)
                           (cdr (assoc (first sd) slot-defaults))
                           (first sd)))
                     defstruct-slot-definitions)))))
         ;; Don't (declare (type <type> struct)) here as the type may be unnamed.

         ;; Record the structure under the instance name, and record the name,
         ;; sorting if requested.  Return the name.

         (setf (get %name% ',type) struct)
         ,(if sort-instances
            (list 'insert-in-sorted-list '%name%
                  (list 'instance-names (list 'quote type)))
            (list 'push '%name% (list 'instance-names (list 'quote type))))
         %name%))

     ;; Define no-eval macro to expand into instance creator. THE is used
     ;; for type checking since parameters are gone in expansion, so can't
     ;; be reset by CHECK-TYPE.
     ;;
     ;;  (defmacro <type> (name &key (<slotname> <default>) ...)
     ;;    "<type> name &key <slot1name> ... <slotNname>
     ;;    [Macro] Expands into CREATE-<type> call.  The ..."
     ;;    (list 'create-<type>
     ;;          (list 'quote name)
     ;;          (list 'the '<slottype> (list 'quote <slotname>) ...)))

     (defmacro ,type
               (%name% &key ,.(mapcar
                               #'(lambda (s) ; get defaults
                                   (declare (symbol s))
                                   (list s (cdr (assoc s slot-defaults))))
                               uncomputed-slots))
       ,(concatenate 'string
                     type-string " name &key"
                     (let ((*print-case* :downcase))
                       (format nil "~{ ~(:~A~)~})" uncomputed-slots))
                     " [Macro]
  Expands into " (symbol-name creator) " call.  The first argument
  is the name of the instance, and the remainder are optional keyword
  arguments for uncomputed slot values, using defaults if not given.")

       (list ',creator
             (list 'quote %name%)
             ,.(mapcar #'(lambda (s)
                           (declare (symbol s))
                           (if (eq (cdr (assoc s slot-types)) T)
                             ;; No THE needed.
                             (list 'list (list 'quote 'quote) s)
                             ;; Nontrivial type check with THE.
                             (list 'list
                                   (list 'quote 'the)
                                   (list 'quote (cdr (assoc s slot-types)))
                                   (list 'list (list 'quote 'quote) s))))
                       uncomputed-slots)))

     ,.(if redefine (list '(restore-instances)))

     ',type))

;;; For CCL users, indent this nicely:
#+:CCL (push (cons 'dst 1) ccl::*fred-special-indent-alist*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Corresponding function.  Nearly identical, so refer to DST for comments.

(defun DEFINE-TYPE (type-and-options &rest slot-definitions
                      &aux defining-form
                           defstruct-type-and-options
                           (defstruct-slot-definitions
                            (list :head))
                           type
                           (type-string "")
                           (documentation nil)
                           (reusable T)
                           (redefine nil)
                           (sort-instances nil)
                           (initial-offset 0)
                           (representation nil)
                           (named T)
                           (type-info nil)
                           (slot-access      (list :head))
                           (macro-access     (list :head))
                           (read-only-slots  (list :head))
                           (computed-slots   (list :head))
                           (uncomputed-slots (list :head))
                           (slot-defaults (list :head))
                           (slot-types (list :head))
                           (slot-info (list :head))
                           creator
                           maker
                           )

  "DEFINE-TYPE <type-and-options>  <slot-spec>*                     [Function]

  Functional version of DST.  Syntax identical EXCEPT that the
  arguments are EVALUTED.  See DST for full documentation.

  Note that functions and macros redefined by this function are NOT
  guaranteed to be compiled."

  (declare (symbol type reusable redefine creator maker)
           (simple-string type-string)
           (list defining-form slot-definitions defstruct-type-and-options
                 defstruct-slot-definitions type-info slot-access macro-access
                 read-only-slots computed-slots uncomputed-slots
                 slot-defaults slot-info slot-types))

  ;; ------------------------------------------------------------------------
  ;; The first section sets up various lists, similar to those in DST.
  ;; ------------------------------------------------------------------------

  ;; Need this here but not in DST since only macros have &whole args.
  (setq defining-form (cons 'dst (cons type-and-options slot-definitions)))

  (make-names-of-things)
  (process-slot-definitions "DST")
  (process-type-definition  "DST")

  ;; ------------------------------------------------------------------------
  ;; The functional version constructs and evaluates the forms which would
  ;; have gone into the progn of DST, in the same order.
  ;; ------------------------------------------------------------------------

  ;; If this is a redefinition, make sure all the instances of the type
  ;; are disposed or saved, checking with or warning user as as appropriate.
  ;; (This is slightly different than the DST version since both redefine
  ;; cases must be included in the code, and of course there is no expansion.)

  (when (member type *structure-types*)
    (when redefine
      (save-instances type computed-slots uncomputed-slots)
      (if *warn-of-redefinitions*
        (warn "~%[SM:DEFINE-TYPE] ~S being redefined. ~A"
              type
              (if (instances type)
                "Instances temporarily saved on
*saved-instances*, and will be redefined as instances of the new type."
                "(There were no instances.)")))
      (destroy-type type))
    (when (not redefine)
      (if *warn-of-redefinitions*
          (if (instances 'type)
            (cerror
             "Will proceed, calling DESTROY-TYPE first."
             "~%[SM:DEFINE-TYPE] Type ~S is defined, and has in-memory instances which~
              ~%would be destroyed by redefinition."
             type)
            (warn "~%[SM:DEFINE-TYPE] Type ~S is being redefined (there were no instances)."
                  type)))
      (destroy-type type)))

  ;; Define instance structure ... identical to DST except eval & backquote.

  (eval `(defstruct
           ,defstruct-type-and-options
           ,.(if documentation (list documentation))
           ,.defstruct-slot-definitions))

  ;; Create a type structure ... expanded form of DST with minor change #+TI

  (setf (get type '$structure-type$)
        (record-new-type
         reusable          slot-access    macro-access
         uncomputed-slots  computed-slots read-only-slots
         slot-defaults     slot-types     slot-info
         representation    initial-offset named
         creator           defining-form  type-info)) ; #+TI problem in macro only
  (setq *structure-types*
        (sort (pushnew type *structure-types*)
              #'(lambda (s1 s2) (string< (symbol-name s1) (symbol-name s2)))))

  ;; Define instance creator ... identical to DST except eval & backquote.

  (eval
   `(defun ,creator
           (%name%
            &optional ,.(mapcar #'(lambda (s)
                                    (declare (symbol s))
                                    (list s (cdr (assoc s slot-defaults))))
                                uncomputed-slots))
      ,(concatenate 'string
                    "CREATE-" type-string " <name> &optional"
                    (let ((*print-case* :downcase))
                      (format nil "~{ ~(<~A>~)~})" uncomputed-slots))
                    " [Function]
  The slot arguments include only uncomputed slots.  Creates and records
  an instance of " type-string " indexed by <name>."
                     (if sort-instances
                       "
  The list of instance names returned by INSTANCES is kept sorted."
                       ""))

      (declare (symbol %name%)
               ,.(mapcar #'(lambda (s)
                             (list 'type (cdr (assoc s slot-types)) s))
                         uncomputed-slots)
               (optimize (safety 1) (space 2) (speed 3)))

      (when (get %name% ',type)
        (if *warn-of-redefinitions*
          (warn ,(concatenate 'string
                              "~%[CREATE-" type-string "] Redefining instance ~A")
                %name%))
        (destroys ',type %name%))

      (let*
        ((struct
          ,(if reusable
             (list 'if (list 'freelist (list 'quote type))
                   (cons
                    'let
                    (cons
                     (list (list 'old-struct (list 'pop (list 'freelist
                                                              (list 'quote type)))))
                     (append (mapcar           ; copy value of uncomputed slots
                              #'(lambda (s+a)
                                  (declare (cons s+a))
                                  (list 'setf
                                        (list (cdr s+a) 'old-struct)
                                        (car s+a)))
                              macro-access)
                             (mapcar           ; set default of computed slots
                              #'(lambda (s)
                                  (declare (symbol s))
                                  (list 'setf
                                        (list (cdr (assoc s slot-access))
                                              'old-struct)
                                        (cdr (assoc s slot-defaults))))
                              computed-slots)
                             '(old-struct))))
                   (cons maker
                         (mapcar
                          #'(lambda (sd)
                              (declare (list sd))
                              (if (member (first sd) computed-slots)
                                (list 'quote (cdr (assoc (first sd) slot-defaults)))
                                (first sd)))
                          defstruct-slot-definitions)))
             (cons maker
                   (mapcar
                    #'(lambda (sd)
                        (declare (list sd))
                        (if (member (first sd) computed-slots)
                          (cdr (assoc (first sd) slot-defaults))
                          (first sd)))
                    defstruct-slot-definitions)))))

        (setf (get %name% ',type) struct)
        ,(if sort-instances
           (list 'insert-in-sorted-list '%name%
                 (list 'instance-names (list 'quote type)))
           (list 'push '%name% (list 'instance-names (list 'quote type))))
        %name%)))

  ;; Define no-eval macro ... identical to DST except eval and backquote.

  (eval
   `(defmacro ,type
              (%name% &key ,.(mapcar
                              #'(lambda (s) ; get defaults
                                  (declare (symbol s))
                                  (list s (cdr (assoc s slot-defaults))))
                              uncomputed-slots))
      ,(concatenate 'string
                    type-string " name &key"
                    (let ((*print-case* :downcase))
                      (format nil "~{ ~(:~A~)~})" uncomputed-slots))
                    " [Macro]
  Expands into " (symbol-name creator) " call.  The first argument
  is the name of the instance, and the remainder are optional keyword
  arguments for uncomputed slot values, using defaults if not given.")

      (list ',creator
            (list 'quote %name%)
            ,.(mapcar #'(lambda (s)
                          (declare (symbol s))
                          (if (eq (cdr (assoc s slot-types)) T)
                            (list 'list (list 'quote 'quote) s)
                            (list 'list
                                  (list 'quote 'the)
                                  (list 'quote (cdr (assoc s slot-types)))
                                  (list 'list (list 'quote 'quote) s))))
                      uncomputed-slots))))

   (if redefine (restore-instances))
   type)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                           SAVING AND LOADING
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun SAVE-TYPE (type &key (path nil) (style :pretty-macro) (omit ())
                       (define-type nil) (compile nil) (append nil)
                       (init-forms nil) (instances (instances type)))
  "save-type <type>                                                 [Function]
             &key :path :style :omit :define-type :compile
                  :append :init-forms :instances
  Saves macro representations of instances of the type indicated.  If
  <path> is omitted, saved to the file loaded from, or a default path
  constructed from *default-instance-file-path*, the type's name, and
  *default-instance-file-type*.  The <style> and <omit> parameters work
  as for PRINTS, though only :macro and :pretty-macro will result in re-
  loadable files.  If <define-type> is T, the form defining the type is
  placed at the front of the file.  If <compile> is T, the saved file
  is compiled.  If <append> is T, <path> must be an existing file which
  is appended to (with no editing).  If <init-forms> is non-nil, it
  should be a list of expressions.  These are written to the file after
  the in-package, but before anything else. If <instances> is supplied,
  it should be a list of names of instances of type <type>, and only
  these are saved; otherwise all instances are saved.  Returns the actual
  path used."
  (check-type type       symbol)
  (check-type path       (or null string pathname))
  (check-type style      keyword)
  (check-type omit       list)
  (check-type init-forms list)
  (check-type instances  list)
  (assert (member type (structure-types)) (type) "Unknown type")
  (if (null path)
    (setf path
          (let ((prev-path (get type '$SM-instance-path$)))
            (declare (type (or string pathname) prev-path))
            (if prev-path
              ;; Don't save to compiled file type if it was loaded
              ;; from the same!
              (make-pathname
               :device    (pathname-device prev-path)
               :directory (pathname-directory prev-path)
               :name      (pathname-name prev-path)
               :type      *default-instance-file-type*)
              ;; Otherwise let file system figure out type.
              (make-pathname
               :directory *default-instance-file-path*
               :name (symbol-name type)
               :type      *default-instance-file-type*)))))
  (let ((*package* (symbol-package type)))
    (with-open-file (stream path
                            :direction
                #-VAX :io     ; CCL and others need input for tabbing
                #+VAX :output ; Vax can't do :IO if it doesn't exist!
                            :if-exists (if append :append :supersede)
                :if-does-not-exist :create)
      (format stream ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Instances of type ~A~%;;; Saved by SAVE-TYPE ~A~%;;; On ~A, a ~A"
              type
              (multiple-value-bind
                (second minute hour date month year)
                (get-decoded-time)
                (declare (integer second minute hour date month year))
                (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
                        date
                        (case month
                          ((1) "Jan") ((2) "Feb") ((3) "Mar") ((4) "Apr")
                          ((5) "May") ((6) "Jun") ((7) "Jul") ((8) "Aug")
                          ((9) "Sep") ((10) "Oct") ((11) "Nov") ((12) "Dec"))
                        (- year 1900)
                        hour minute second))
              (machine-instance)
              (machine-type))
      (format stream "~%~%(in-package ~S)" (package-name (symbol-package type)))
      (when init-forms
        (format stream "~%")
        (dolist (form init-forms) (format stream "~%~S" form)))
      (if define-type
      (let ((*print-pretty* t) (*print-escape* t) (*print-circle* nil)
                (*print-case* :upcase) (*print-array* t)
                #+:ccl (ccl::*print-structure* t) (dst-form (defining-form type)))
            (format stream "~%~%(~S ~A~{~&  ~S~})"
                    (first dst-form)
                    (prin1-to-string (second dst-form))
                    (cddr dst-form))))
      (dolist (i (sort (copy-list instances)
                       #'(lambda (s1 s2)
                           (string<= (symbol-name s1) (symbol-name s2)))))
        (declare (symbol i))
        (format stream "~&~%")
        (prints type i :style style :omit omit :stream stream))
      (format stream "~&~%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EOF~%")))
  ;; Now that it worked, safe to update path used.
  (setf (get type '$SM-instance-path$) path
        *default-instance-file-path* (pathname-directory path))
  (if compile
    #+:ccl (ccl:eval-enqueue `(compile-file ,(namestring path)))
    #-:ccl (compile-file path)
    )
  path)
(proclaim '(function save-type
            (symbol &key (or null string pathname) keyword list t t list)
            pathname))

(defun LOAD-TYPE (type &key (path nil))
  "load-type <type>  &key :path                                     [Function]
  Loads the file indicated in <path>, which presumably has macro definitions
  of instances of <type>, and records the path name.  If <path> is nil,
  guesses at a path name based on previous loads/saves, or on the type.
  The <type> need not be defined yet, if the file defines it.  If an
  :after-load type option has been specified, the expression stored there
  is evaluated after the file is loaded."
  (check-type type symbol)
  (check-type path (or null string pathname))
  (if (null path)
    (setf path
          (or (get type '$SM-instance-path$)
              (make-pathname
               :directory *default-instance-file-path*
           :name (symbol-name type)))))
  (let ((*package* (symbol-package type)))
    #+HP (format T "~&; Loading ~A ..." path)
    (load path))
  ;; Make sure the type was indeed defined.
  (assert (member type (structure-types)) (type)
          "Type ~A still not defined after LOAD-TYPE." type)
  ;; Now that it worked, safe to record the new path for future defaults.
  (setf (get type '$SM-instance-path$) path
        *default-instance-file-path* (pathname-directory path))
  ;; Run :after-load method, if present.
  (let ((after-load (type-info type :after-load)))
    (if after-load (funcall after-load)))
  path)
(proclaim '(function load-type (symbol &key (or null string pathname))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide :SM)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; EOF